﻿(****************************************************************************
 * 
 *  Bistro FSharp Extensions Copyright © 2003-2009 Hill30 Inc
 *
 *  This file is part of Bistro Framework.
 *
 *  Bistro FSharp Extensions is free software: you can redistribute it and/or modify
 *  it under the terms of the GNU Lesser General Public License as published by
 *  the Free Software Foundation, either version 3 of the License, or
 *  (at your option) any later version.
 *
 *  Bistro FSharp Extensions is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU Lesser General Public License for more details.
 *
 *  You should have received a copy of the GNU Lesser General Public License
 *  along with Bistro FSharp Extensions.  If not, see <http://www.gnu.org/licenses/>.
 *  
 ***************************************************************************)
#light

namespace Bistro.FS

module  Definitions =
    open System
    open System.Reflection

    open Microsoft.FSharp.Reflection

    type ictx = Bistro.Controllers.IExecutionContext

    /// annotates a session-scoped value
    type session<'a> =
        | SessionValue of 'a
        member x.Value = match x with SessionValue a -> a
        
    /// annotates a form-scoped value
    type form<'a> =
        | FormValue of 'a
        member x.Value = match x with FormValue a -> a

    type Wrapper = 
        | Wrap of (obj -> obj) list
        | Unwrap of (obj -> obj) list

    let ofSsn = function
    | SessionValue v -> v
    
    let ofForm = function
    | FormValue v -> v
    
    let sessiont = typeof<session<_>>.GetGenericTypeDefinition()
    let formt = typeof<form<_>>.GetGenericTypeDefinition()
    let optiont = typeof<Option<_>>.GetGenericTypeDefinition()
    
    let valid_unions = ["SessionValue"; "FormValue"; "Option"]
            
    /// gets the generic type parameter of this type. note that this function
    /// assumes that the supplied type is a specific definition of a generic
    /// type, and that it has at least one type parameter
    let get_generic (t: Type) = t.GetGenericArguments().[0]
    
    /// determines whether the supplied type is the same underlying type
    /// as the search type
    let as_generic_of_type (target_type: Type) (search_type: Type) = 
        if target_type.IsGenericType && target_type.GetGenericTypeDefinition() = search_type then
            Some <| target_type.GetGenericArguments().[0]
        else None

    /// active pattern for session markers. If matched, the inner type is returned
    let (|SessionMarker|_|) input = as_generic_of_type input sessiont
    /// active pattern for form markers. If matched, the inner type is returned
    let (|FormMarker|_|) input = as_generic_of_type input formt
    /// active pattern for option markers. If matched, the inner type is returned
    let (|OptionMarker|_|) input = as_generic_of_type input optiont
            
    /// determines whether the supplied type is a supported marker type
    let isSupportedMarkerType = function 
    | OptionMarker inner | SessionMarker inner | FormMarker inner -> true
    | _ -> false
    
    /// A short propety accessor that can be curried
    let inline private shortAccessor (field: PropertyInfo) instance = field.GetValue(instance, null)
    
    /// recursively computes a list of discriminator accessors
    let rec private doPrecomputeUnwrap (t: Type) =
        if not (FSharpType.IsUnion t && isSupportedMarkerType t) then []
        else
            let caseInfo = FSharpType.GetUnionCases(t)
            match 
                // there doesn't seem to be a clean way to identify which specific 
                // discriminator we're holding on to. as a result, we have to rumage through
                // and say that
                //      if there's one union case and there's one value on it, done
                //      if there's more than one value on the union case, we have no way of picking. kthxbye.
                //      if there's more than one union case, we can keep looking until
                //          we find a single discriminator, with a single value, whose accessor 
                //          property's name matches a property name that our instance has
                seq { for case in caseInfo -> case.GetFields() } |>
                Seq.tryPick (fun (f: PropertyInfo array) -> 
                            if not (Array.length f = 1) then None 
                            else
                                let prop = t.GetProperty(f.[0].Name)
                                if prop = null then None
                                else Some prop
                            ) with
            | None -> []
            | Some field -> [shortAccessor field] @ doPrecomputeUnwrap field.PropertyType
    
    /// precomputes a path of discriminator accessors for unwrapping a value
    let precomputeUnwrap t = Unwrap <| doPrecomputeUnwrap t

    /// unwraps a value given the supplied Unwrap path
    let unwrap v path = 
        match path with 
        | Unwrap access -> List.fold (fun prev_res accessor -> accessor prev_res) v access
        | _ -> failwith "Mixed access paths are not valid. Path must be an Unwrap discriminator."

    // precomputes a concrete type constructorfor values of the given generic type
    // the generic type parameter is assumed to be the generic 
    // discriminated union. inner is the type parameter that will be
    // supplied to the type constructor.
    let private instantiate_as (inner: Type) (genericInstanceType: Type) =
        let concrete = inner.MakeGenericType [|genericInstanceType.GetGenericArguments().[0]|]
        let ctor = FSharpValue.PreComputeUnionConstructor(
                        match
                            Array.tryPick (fun (case: UnionCaseInfo) -> match case.GetFields().Length with | 1 -> Some case | _ -> None)
                                <| FSharpType.GetUnionCases(concrete) with
                        | Some case -> case
                        | None -> failwith <| sprintf "Unable to find appropriate union case for %s" genericInstanceType.Name
                        )
        
        // option types are special case. we want to be sure that if the inbound value is
        // null that we use the None discriminator, otherwise we'll end up with a Some(null)
        // that's expensive to check for
        if inner = optiont then
            let emptyCtor = 
                FSharpValue.PreComputeUnionConstructor(
                    (FSharpType.GetUnionCases(concrete) |>
                     Array.pick (fun (case: UnionCaseInfo) -> match case.GetFields().Length with | 0 -> Some case | _ -> None)))
            fun parm -> 
                if parm = null then
                    emptyCtor [||]
                else
                    ctor [|parm|]
        else        
            fun parm -> ctor [|parm|]
    
    /// changes the type of v to t using the IConvertible interface.                
    let private changeType t v = 
        if not (v = null) && not (v.GetType() = t) then 
            try Convert.ChangeType(v, t) 
            with | :? InvalidCastException as exn -> 
                raise (ApplicationException (sprintf "%s does not implement the IConvertible interface, and '%A' is not of type %s" (v.GetType().Name) v t.Name, exn))
        else v
                    
    /// Recursivly computes an access path for the given composed marker type.
    let rec private doPrecomputeWrap (composedMarkerTypes: Type) =
        let return_list, next_parm =
            match composedMarkerTypes with 
            | SessionMarker inner -> [instantiate_as sessiont composedMarkerTypes], inner
            | FormMarker inner -> [instantiate_as formt composedMarkerTypes], inner
            | OptionMarker inner -> [instantiate_as optiont composedMarkerTypes], inner
            | _ -> [fun parms -> changeType composedMarkerTypes parms], null // lambda is here because we need to fit the obj[] signature
    
        // this will be used to wrap up an element into all of the expected marker types, 
        // which needs to be done from the inside out
        
        // we trade off tail-recursion for a naturally inverted list here, because
        // the depth of a marker composition should never be excessive, and as a result
        // we can continue to traverse the list left to right
        (if next_parm = null then [] else doPrecomputeWrap next_parm) @ return_list 

    /// Precomputes an access path for the given composed marker type. A composed marker type is
    /// a Type of the form marker_a<marker_b<value>>
    let precomputeWrap composedMarkerTypes =
        Wrap <| doPrecomputeWrap composedMarkerTypes
        
    /// wraps a value given the supplied Wrap path
    let wrap v path =
        match path with 
        | Wrap access -> List.fold (fun prev_res accessor -> accessor prev_res) v access
        | _ -> failwith "Mixed access paths are not valid. Path must be a Wrap discriminator."
